home *** CD-ROM | disk | FTP | other *** search
Modula Implementation | 1991-01-21 | 22.7 KB | 625 lines |
- (*# call(o_a_copy => off) *)
- (*%F _fdata *)
- (*# call(seg_name => null) *)
- (*%E *)
- (*# module(implementation=>on) *)
- (*# data(seg_name => null) *)
- IMPLEMENTATION MODULE QCkermit;
-
- (* This JPI Modula-2 module is part of *)
-
- (* QC -- a communications program *)
- (* by Carl Neiburger *)
- (* 169 N. 25th St.*)
- (* San Jose, Calif. 95116 *)
-
- (* CompuServe No. 72336,2257 *)
-
- FROM Storage IMPORT ALLOCATE, DEALLOCATE;
- FROM NFIO IMPORT Close, Create, File, OK, Open, PathStr, PathTail, Size,
- RdChar, WrBin;
- FROM Str IMPORT Append, CHARSET, Concat, Copy, Insert, Length;
- FROM QCdisp IMPORT DataBytes, DataLeft, DataRegisters, DisplayData, Errs,
- PromptForChar, ShowErrorType, ShowFileName, ShowPacketSize, IncrDataBytes,
- ShowTransferTime, ShowTimeLeft, StartDisplay, StatusMessage, StopDisplay,
- CloseError, CreateError, OpenError, TimeoutMsg, TimeoutAbortMsg,
- Kermit, WriteErrorMsg;
- FROM Lib IMPORT Fill, Move, SetJmp, LongJmp, LongLabel;
- FROM QCkpack IMPORT GetDefinitions, SendDefaults, MyExtControls, PackPtr,
- RecvBuf, RecvCount, RecvPacket, RecvSeq, RecvType, SendBuf, SendCount,
- SendPacket, SendPacketType, SendSeq, SendType, PacketSize, CtlChar,
- TheirDefs, InitDefinitions;
- FROM Timer IMPORT StartTimer, ForTransfer, ForPacket;
- FROM UTIL IMPORT NUMSET, SBITSET, str2, str3, str6;
- FROM PathFind IMPORT ParsePath;
-
- CONST
- BUFFERSIZE = 1024;
- QuotedChars = NUMSET{63..96,63+128..96+128};
- ControlChars = CHARSET{0C..37C,177C..237C,377C};
- KAbortMsg = 'Sending files aborted';
- TransferAborted = 'File transfer aborted.';
-
- TYPE
- AbortType = (NoSoh, BadSf, NotS, NotSFBZ, NotDZ);
- BreakType = (NoBreak, BX, BZ, BC, BE);
-
- VAR
- AbortState : AbortType;
- AbortLbl : LongLabel; (* return point for abort exit *)
- BreakState : BreakType;
-
- PROCEDURE DisplayErrMsg;
- VAR Msg: PathStr;
- BEGIN
- Move( RecvBuf, ADR(Msg), RecvCount );
- IF RecvCount < SIZE(Msg) THEN
- Msg[RecvCount] := 0C
- END;
- Insert(Msg, 'Error: ', 0);
- StatusMessage(Msg, TRUE);
- END DisplayErrMsg;
-
- PROCEDURE BreakAck (Achar : CHAR);
- BEGIN (* SEND ACK or NAK *)
- SendPacket( 1, (SendSeq + 1) MOD 64, 'Y', ADR(Achar) );
- END BreakAck;
-
- PROCEDURE SendKermit( FileList: FilePtr );
-
- TYPE
- SendStateType = (SendStart,
- SendHdr,
- SendData,
- SendZPkt,
- SendBPkt,
- SendDone,
- SendAbort);
- VAR
- SendState : SendStateType;
- Data : PackPtr; (* Where data is stored before being sent *)
- abyte : SHORTCARD;
- ThisChar,
- PrevChar : CHAR;
- Msg : PathStr;
- FileName : PathTail;
- ChrLen,
- TCount, (* to update DataBytes *)
- MaxOutData,
- RepCount : CARDINAL;
- BytesToGo : LONGINT;
- WeInitiatedAbort,
- LastFile : BOOLEAN;
- FileBuffer : ARRAY [1..BUFFERSIZE] OF CHAR;
- Fi : File;
- SaveStr : str6;
-
- PROCEDURE ResendIt ( Retries : SHORTINT );
- (* resends packet; if it gets a nak, it repeats for up to Retries times.
- If it fails, it sets SendState to Abort. *)
- BEGIN
- REPEAT
- INC(DataRegisters[FALSE, Errs]);
- DisplayData( Errs, FALSE );
- SendPacket( SendCount, SendSeq, SendType, SendBuf );
- CASE RecvPacket() OF
- 'Y': RETURN;
- |'N': IF (RecvSeq = (SendSeq+1) MOD 64) THEN
- SendSeq := RecvSeq;
- RETURN
- ELSE
- DEC(Retries)
- END;
- |'E': DisplayErrMsg;
- SendState := SendAbort;
- WeInitiatedAbort := FALSE;
- RETURN;
- |'@': WeInitiatedAbort := TRUE;
- SendState := SendAbort;
- |'T': DEC(Retries, 2);
- |ELSE DEC(Retries)
- END;
- UNTIL Retries < 1;
- StatusMessage (TimeoutAbortMsg, FALSE);
- SendState := SendAbort;
- WeInitiatedAbort := TRUE;
- END ResendIt;
-
- PROCEDURE QuotedChar(ch: CHAR; VAR i: CARDINAL): str3;
- VAR chrstr: str3;
- BEGIN
- Fill( ADR(chrstr), SIZE(chrstr), 0);
- IF (7 IN SBITSET(ch)) AND (TheirDefs.Bit8Quote <> ' ') THEN
- chrstr[0] := TheirDefs.Bit8Quote;
- EXCL( SBITSET(ch), 7 );
- i := 1
- ELSE
- i := 0
- END;
- IF (ch IN ControlChars) THEN
- ch := CHR( SBITSET(ch)/SBITSET(40H));
- chrstr[i] := '#';
- INC(i);
- ELSIF ch IN MyExtControls THEN
- chrstr[i] := '#';
- INC(i);
- END; (* CONTROL QUOTING *)
- chrstr[i] := ch;
- INC(i);
- RETURN chrstr
- END QuotedChar;
-
- PROCEDURE RepChar(count: CARDINAL): str2;
- VAR repstr: str2;
- BEGIN
- repstr[0] := TheirDefs.RepChar;
- repstr[1] := CHR(count + 21H); (* cq, to increment counter *)
- RETURN repstr
- END RepChar;
-
- PROCEDURE SendChar;
- BEGIN
- Move(ADR(SaveStr), ADR(Data^[SendCount+1]), ChrLen);
- INC(SendCount, ChrLen);
- SaveStr[0] := 0C;
- PrevChar := ThisChar;
- RepCount := 0
- END SendChar;
-
- BEGIN (* SendKermit *)
- NEW(Data);
- NEW(RecvBuf);
- InitDefinitions;
- SendState := SendStart;
- BreakState := NoBreak;
- LastFile := FALSE;
- StartDisplay( TRUE, Kermit, FALSE );
- LOOP
- IF SetJmp ( AbortLbl ) <> 0 THEN
- EXIT
- END;
- CASE SendState OF
- SendStart: SendDefaults( 'S' );
- INC(SendState);
- |SendHdr: IF SendType = 'S' THEN
- GetDefinitions;
- ShowPacketSize(PacketSize);
- ShowErrorType(TheirDefs.CheckType = '3');
- END;
- ShowFileName( FileList^.Name, FALSE );
- FileName := '*.*';
- Fi := Open(FileList^.Name);
- IF (Fi = MAX(CARDINAL)) OR
- NOT ParsePath(FileList^.Name, FileName) THEN
- StatusMessage(OpenError, FALSE);
- WeInitiatedAbort := TRUE;
- SendState := SendAbort
- ELSE
- Fill( ADR(DataRegisters), SIZE(DataRegisters), 0);
- BytesToGo := VAL(LONGINT, Size(Fi));
- DataRegisters[FALSE,DataLeft]:=VAL(LONGCARD,BytesToGo);
- StartTimer(ForPacket);
- StartTimer(ForTransfer);
- ShowTimeLeft( FALSE );
- SaveStr[0] := 0C; (* Initialize for SendData *);
- SendPacket( Length(FileName), (SendSeq + 1) MOD 64,
- 'F', ADR(FileName) );
- INC(SendState);
- MaxOutData := PacketSize+30H-ORD(TheirDefs.CheckType);
- IF PacketSize <= 94 THEN
- DEC(MaxOutData, 2)
- END;
- PrevChar := RdChar(Fi); (* initialize for SendData *)
- END;
- |SendData: SendCount := 0;
- TCount := 0;
- RepCount := 0;
- IF SaveStr[0] > 0C THEN
- SendChar
- END;
- LOOP
- IF (SendCount >= MaxOutData) OR (BytesToGo = 0) THEN
- EXIT
- END;
- ThisChar := RdChar(Fi);
- DEC(BytesToGo);
- INC(TCount);
- IF (PrevChar=ThisChar) AND (TheirDefs.RepChar>' ')
- AND ( BytesToGo > 0) AND (RepCount < 94) THEN
- INC(RepCount);
- ELSE (* different char *)
- IF RepCount < 2 THEN
- Copy( SaveStr, QuotedChar(PrevChar, ChrLen));
- IF RepCount = 1 THEN
- Append( SaveStr, SaveStr);
- ChrLen := ChrLen * 2
- END;
- ELSE
- Concat( SaveStr, RepChar(RepCount),
- QuotedChar(PrevChar, ChrLen));
- INC( ChrLen, 2 );
- END;
- IF SendCount + ChrLen <= MaxOutData THEN
- SendChar
- ELSE
- EXIT
- END;
- END; (* different char *)
- END; (* WHILE Read a char *)
- IncrDataBytes(TCount, FALSE);
- DisplayData ( DataBytes, FALSE );
- IF BytesToGo = 0 THEN
- SendState := SendZPkt
- END;
- SendPacket( SendCount, (SendSeq + 1) MOD 64, 'D', Data );
- CASE BreakState OF
- |BC : EXIT;
- |BE : SendState := SendAbort;
- WeInitiatedAbort := TRUE;
- |BX : SendState := SendZPkt;
- |BZ : SendState := SendZPkt;
- LastFile := TRUE;
- END;
- |SendZPkt: Close(Fi); (* End of File *)
- Concat(Msg, 'File ', FileName);
- IF BreakState = NoBreak THEN
- Append(Msg, ' sent.');
- ELSE
- Append(Msg, ' partly sent.');
- END;
- StatusMessage(Msg, FALSE );
- IF LastFile OR (FileList^.Next = NIL) THEN
- INC(SendState)
- ELSE
- FileList := FileList^.Next;
- SendState := SendHdr
- END; (* Get next file *)
- IF BreakState = BX THEN
- BreakState := NoBreak
- END;
- SendPacketType('Z');
- ShowTransferTime;
- |SendBPkt: SendPacketType('B'); (* Last file sent *)
- SendState := SendDone;
-
- |SendDone: IF BreakState <> NoBreak THEN (* Completed Sending *)
- StatusMessage(TransferAborted, FALSE);
- END;
- EXIT;
-
- |SendAbort: Close(Fi);
- IF WeInitiatedAbort THEN
- StatusMessage(KAbortMsg, FALSE);
- AbortState := BadSf;
- SendPacket( Length(KAbortMsg), 0, 'E', ADR(KAbortMsg));
- ELSE
- SendPacketType('Y')
- END;
- ShowTransferTime;
- EXIT;
- END; (* CASE of SendState *)
- WHILE (RecvPacket() IN CHARSET{'Q','T'}) OR
- ((RecvSeq <> SendSeq) AND (RecvPacket() IN CHARSET{'Q','T'}))
- AND (SendState <> SendAbort) DO
- ResendIt(10)
- END;
- IF (SendState <> SendAbort) THEN
- CASE RecvType OF
- 'Y': IF RecvCount > 1 THEN
- CASE CHR(RecvBuf^[1]) OF
- 'X': SendState := SendZPkt;
- |'Z': SendState := SendZPkt;
- LastFile := TRUE;
- END
- END;
- |'N': ResendIt(10);
- |'R': SendState := SendStart;
- |'E': DisplayErrMsg;
- SendState := SendAbort;
- WeInitiatedAbort := FALSE;
- ELSE SendState := SendAbort;
- WeInitiatedAbort := TRUE;
- END
- END
- END; (* LOOP *)
- StopDisplay;
- DISPOSE(RecvBuf);
- DISPOSE(Data);
- END SendKermit;
-
- PROCEDURE ReceiveKermit( Path, GetFile : ARRAY OF CHAR);
- (* If GetFile > 0C, R packet will be sent *)
- CONST buffersize = 1280; (* must be a multiple of 128 *)
- TYPE
- RecvStateType = ( RecvGet,
- RecvStart,
- RecvHdr,
- RecvData,
- RecvDone,
- RecvAbort);
-
- VAR
- RecvState : RecvStateType;
- ReplaceFile : BOOLEAN;
- Bit8,
- LastSeqNum : SHORTCARD;
- Retries : SHORTINT;
- RCount,
- i, j,
- CharCount : CARDINAL;
- FileName,
- Msg : PathStr;
- Fi : File;
- FileBuffer : ARRAY [1..BUFFERSIZE] OF CHAR;
-
- PROCEDURE SendNak;
- BEGIN
- IF Retries > 0 THEN (* Ask for a retransmission *)
- SendPacketType('N');
- INC(DataRegisters[TRUE, Errs]);
- DisplayData( Errs, TRUE );
- DEC(SendSeq);
- DEC(Retries);
- ELSE
- RecvState := RecvAbort;
- StatusMessage(TimeoutMsg, FALSE);
- END;
- END SendNak;
-
- PROCEDURE Resend;
- BEGIN
- IF RecvType = 'T' THEN (* get it over twice as fast *)
- DEC(Retries)
- END;
- IF Retries > 0 THEN
- INC(DataRegisters[FALSE, Errs]);
- DisplayData( Errs, FALSE );
- SendPacket( SendCount, SendSeq, SendType, SendBuf );
- DEC(Retries)
- ELSE
- StatusMessage (TimeoutAbortMsg, FALSE);
- RecvState := RecvAbort;
- END
- END Resend;
-
- PROCEDURE SetAbort;
- VAR ch : CHAR;
- BEGIN
- IF RecvState = RecvData THEN
- PromptForChar('Abort (A)ll, (F)ile, (T)ransfer), (Panic)', ch);
- ELSE
- PromptForChar('Abort (A)ll, (Panic)', ch);
- END;
- CASE CAP(ch) OF
- 'A': RecvState := RecvAbort;
- BreakState := BE;
- |'F': BreakState := BX;
- |'T': BreakState := BZ;
- |'P': BreakState := BC;
- LongJmp( AbortLbl, MAX(CARDINAL) ); (* TRY to do without this *)
- ELSE BreakState := BE;
- END;
- END SetAbort;
-
- BEGIN (* ReceiveKermit *)
- NEW(RecvBuf);
- RecvType := ' '; (* initialize to inconsequential value *)
- ReplaceFile := FALSE;
- InitDefinitions;
- LastSeqNum := 0;
- IF GetFile[0] > 0C THEN
- RecvState := RecvGet;
- ELSE
- RecvState := RecvStart;
- END;
- BreakState := NoBreak;
- Retries := 10;
- StartDisplay( TRUE, Kermit, TRUE );
- LOOP
- IF SetJmp ( AbortLbl ) <> 0 THEN
- EXIT
- END;
- CASE RecvState OF
- RecvGet: SendDefaults( 'I' );
- CASE RecvPacket() OF
- 'Y': GetDefinitions;
- Concat( Msg, 'Receiving ', GetFile );
- SendPacket( Length(GetFile), 0, 'R', ADR(GetFile) );
- INC(RecvState);
- |'N', 'Q', 'T': Resend;
- |'@': SetAbort;
- ELSE
- IF RecvType = 'E' THEN (* Error Packet *)
- DisplayErrMsg;
- END;
- RecvState := RecvAbort; (* Abort if not INIT packet *)
- AbortState := NotS;
- END; (* CASE *)
- |RecvStart: CASE RecvPacket() OF
- 'N', 'Q', 'T': Resend;
- |'S': SendDefaults( 'Y' );
- GetDefinitions; (* Init packet *)
- SendSeq := 0;
- INC(RecvState);
- ShowPacketSize(PacketSize);
- ShowErrorType(TheirDefs.CheckType = '3');
- |'@': SetAbort;
- ELSE
- IF RecvType = 'E' THEN (* Error Packet *)
- DisplayErrMsg;
- END;
- RecvState := RecvAbort; (* Abort if not INIT packet *)
- AbortState := NotS;
- END; (* CASE *)
- (* Receive FileName; Valid received msg type : S,Z,F,B *)
- |RecvHdr: CASE RecvPacket() OF
- 'N', 'Q', 'T': Resend;
- |'S': RecvState:= RecvStart;
- |'Z': SendPacketType('N');
- |'B': RecvState := RecvDone;
- |'@': SetAbort;
- |'F': Move(RecvBuf, ADR(FileName), RecvCount);
- FileName[RecvCount] := 0C;
- Fill( ADR(DataRegisters), SIZE(DataRegisters), 0);
- ShowFileName( FileName, TRUE );
- INC(RecvState);
- Fi := Create(FileName);
- IF Fi = MAX(CARDINAL) THEN
- Msg := 'Error creating file';
- SendPacket(Length(Msg),(SendSeq+1) MOD 64,'E',ADR(Msg));
- RecvState := RecvAbort;
- StatusMessage(CreateError, FALSE)
- END;
- SendPacketType('Y');
- StartTimer(ForPacket);
- StartTimer(ForTransfer);
- |ELSE (* Not S,F,B,Z packet *)
- IF RecvType = 'E' THEN (* Error Packet *)
- DisplayErrMsg;
- END;
- RecvState := RecvAbort;
- AbortState := NotSFBZ;
- END; (* CASE RecvType *)
- |RecvData: IF RecvPacket() IN CHARSET{'N', 'Q', 'T'} THEN
- SendNak (* Receive Data -- Valid msg type : D,Z *)
- ELSIF RecvType = '@' THEN
- SetAbort;
- CASE BreakState OF
- |BC : EXIT;
- |BE : RecvState := RecvAbort;
- |BX : BreakAck('X');
- BreakState := NoBreak;
- |BZ : BreakAck('Z');
- END;
- Concat(Msg, ' Receiving file ', FileName );
- Append(Msg, ' Interrupted');
- StatusMessage( Msg, FALSE );
- ELSIF LastSeqNum = RecvSeq THEN
- SendPacketType('Y')
- ELSE
- Retries := 10;
- LastSeqNum := RecvSeq;
- CASE RecvType OF
- 'D': i := 1;
- RCount := 0;
- WHILE i <= RecvCount DO (* Write Data to file *)
- IF (TheirDefs.RepChar <> ' ')
- AND (CHR(RecvBuf^[i]) = TheirDefs.RepChar) THEN
- INC(i);
- CharCount := ORD(RecvBuf^[i]) - 20H;
- INC(i);
- ELSE
- CharCount := 1
- END;
- IF (TheirDefs.Bit8Quote<>' ') AND (* 8th bit quoting *)
- (CHR(RecvBuf^[i]) = TheirDefs.Bit8Quote) THEN
- INC(i);
- Bit8 := 80H;
- ELSE
- Bit8 := 0
- END;
- IF RecvBuf^[i] = SHORTCARD(TheirDefs.CntrlQuote) THEN
- INC(i); (* control char *)
- IF RecvBuf^[i] IN QuotedChars THEN
- RecvBuf^[i] := SHORTCARD(
- SBITSET(RecvBuf^[i])/SBITSET(40H));
- END
- END; (* CONTROL character *)
- INC(RecvBuf^[i], Bit8);
- FOR j := 1 TO CharCount DO
- WrBin( Fi, RecvBuf^[i], 1 )
- END;
- IF NOT OK THEN
- StatusMessage(WriteErrorMsg, FALSE);
- RecvState := RecvAbort;
- Msg := WriteErrorMsg;
- SendPacket( Length(Msg), (SendSeq+1) MOD 64,
- 'E', ADR(Msg) );
- SendPacketType('N');
- END; (* IO error *)
- INC(RCount, CharCount);
- INC(i);
- END; (* WHILE *)
- IncrDataBytes(RCount, TRUE);
- DisplayData ( DataBytes, TRUE );
- SendPacketType('Y');
- |'F': DEC( SendSeq ); (* repeat *)
- SendPacketType('Y');
- |'Z': Close(Fi); (* End of Incoming File *)
- ShowTransferTime;
- IF NOT OK THEN
- StatusMessage(CloseError, TRUE)
- END;
- RecvState := RecvHdr;
- SendPacketType('Y');
- ELSE (* Not D,Z packet *)
- IF RecvType = 'E' THEN (* Error Packet *)
- DisplayErrMsg;
- END;
- RecvState := RecvAbort; (* Abort if not init packet *)
- AbortState := NotDZ;
- END; (* CASE RecvType *)
- END; (* Got a good packet *)
- |RecvDone: SendPacketType('Y'); (* Completed Receiving *)
- IF BreakState <> NoBreak THEN
- StatusMessage(TransferAborted, FALSE);
- END;
- EXIT;
- |RecvAbort: Msg := 'Receiving file(s) aborted';
- StatusMessage(TransferAborted, FALSE);
- SendPacket( Length(TransferAborted), 0, 'E',
- ADR(TransferAborted) );
- ShowTransferTime;
- Close(Fi);
- EXIT;
- END; (* CASE of RecvState *)
- END; (* LOOP *)
- StopDisplay;
- DISPOSE(RecvBuf)
- END ReceiveKermit;
-
- PROCEDURE KermitCmd( Cmd: CHAR );
- TYPE
- CmdStateType = (CmdInit,
- CmdSend,
- CmdDone);
- VAR
- CmdState : CmdStateType;
- Retries : SHORTINT;
-
- BEGIN (* KermitCmd *)
- NEW(RecvBuf);
- InitDefinitions;
- CmdState := CmdInit;
- BreakState := NoBreak;
- Retries := 10;
- LOOP
- IF SetJmp ( AbortLbl ) <> 0 THEN
- EXIT
- END;
- CASE CmdState OF
- CmdInit: SendDefaults( 'I' );
- |CmdSend: GetDefinitions;
- SendPacket( 1, 0, 'G', ADR(Cmd) );
- |CmdDone: EXIT;
- END; (* CASE of CmdState *)
- CASE RecvPacket() OF
- 'Y': INC(CmdState);
- Retries := 10;
- |'N': ;
- |'E': DisplayErrMsg;
- EXIT;
- |'@': Retries := 0;
- |'T': DEC(Retries, 2);
- |ELSE DEC(Retries)
- END;
- IF Retries < 1 THEN
- StatusMessage('Command not acknowledged.', TRUE);
- EXIT
- END;
- END; (* LOOP *)
- DISPOSE(RecvBuf);
- END KermitCmd;
-
- END QCkermit.
-